home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / TUTORIAL.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  23.2 KB  |  755 lines
  1. ;;; =============================================
  2. ;;; The Tutorial Engine
  3. ;;;
  4. ;;;     Bob Beal
  5. ;;;
  6. ;;; Copyright 1986,1987 (c) Texas Instruments
  7. ;;; =============================================
  8.  
  9.  
  10. ;;; Auxiliary macros =========================
  11.  
  12. ;; these might be useful anywhere
  13.  
  14. ;; form: (push value var)
  15. ;; push "value" onto list stored at "var"
  16. ;; not a generalized-variable push
  17. (macro push
  18.   (lambda (e)
  19.     (let ((value (cadr e))
  20.       (var (caddr e)))
  21.       `(set! ,var (cons ,value ,var)))))
  22.  
  23. ;; form: (in-bounds? low value high)
  24. ;; tests "low" <= "value" < "high"
  25. (macro in-bounds?
  26.   (lambda (e)
  27.     (let ((lo (cadr e))
  28.       (x (caddr e))
  29.       (hi (cadddr e)))
  30.       `(and (<= ,lo ,x) (< ,x ,hi)))))
  31.  
  32. ;;; data structure definitions =========================
  33.  
  34. (define-structure tutorial
  35.           (name "")
  36.           (writeln-extensions do-nothing)
  37.           (frame-list '())
  38.           (visited-list '())
  39.           (frame-number #F)
  40.           (name-list '())
  41.           (tc #F)
  42.           (index #F)
  43.           )
  44.  
  45. ; arg is a "frame"
  46. (macro frame-name      (lambda (e) `(list-ref ,(cadr e) 1)))
  47. (macro frame-lines-before (lambda (e) `(list-ref ,(cadr e) 2)))
  48. (macro frame-item      (lambda (e) `(list-ref ,(cadr e) 3)))
  49. (macro frame-lines-after  (lambda (e) `(list-ref ,(cadr e) 4)))
  50. (macro frame-dependencies (lambda (e) `(list-ref ,(cadr e) 5)))
  51. (macro frame-tc-entry      (lambda (e) `(list-ref ,(cadr e) 6)))
  52. (macro frame-index-entry  (lambda (e) `(list-ref ,(cadr e) 7)))
  53. (macro frame?          (lambda (e) `(eq? (car ,(cadr e)) 'frame)))
  54. ; A data-driven SET! would be preferable to the following.
  55. (macro set-frame-name!      (lambda (e) `(set-car! (cdr ,(cadr e)) ,(caddr e))))
  56.  
  57.  
  58. ;;; Shorthand expressions for common idioms =========================
  59.  
  60. ;; for arbitrary frames -------------------------
  61.  
  62. ;; form: (nth-frame number)
  63. (macro nth-frame
  64.   (lambda (e)
  65.     (let ((n (cadr e)))
  66.       `(vector-ref (tutorial-frame-list *tutorial*) ,n))))
  67.  
  68. ;; form: (frame-visited? frame)
  69. (macro frame-visited?
  70.   (lambda (e)
  71.     (let ((e (cadr e)))
  72.       `(vector-ref (tutorial-visited-list *tutorial*)
  73.            (frame->number ,e)))))
  74.  
  75. ;; form: (set-frame-visited! frame true-or-false)
  76. (macro set-frame-visited!
  77.   (lambda (e)
  78.     (let ((e (cadr e)) (value (caddr e)))
  79.       `(vector-set! (tutorial-visited-list *tutorial*)
  80.             (frame->number ,e)
  81.             ,value))))
  82.  
  83. ;; form: (frame->number frame)
  84. ;; given a frame, return its number
  85. (macro frame->number
  86.   (lambda (e)
  87.     (let ((e (cadr e)))
  88.        `(cdr (assq (frame-name ,e) (tutorial-name-list *tutorial*))))))
  89.  
  90. ;; form: (name->frame name)
  91. ;; given a frame name, return its frame
  92. (macro name->frame
  93.   (lambda (e)
  94.     (let ((name (cadr e)))
  95.        `(nth-frame (cdr (assq ,name (tutorial-name-list *tutorial*)))))))
  96.  
  97. ;; for the executing tutorial -------------------------
  98.  
  99. ;; form: (unstarted-tutorial?)
  100. ;; has this tutorial been run since loading?
  101. (macro unstarted-tutorial?
  102.   (lambda (e)
  103.     '(not (vector? (tutorial-frame-list *tutorial*)))))
  104.  
  105. ;; form: (tutorial-length)
  106. ;; returns the number of frames in the tutorial
  107. (macro tutorial-length
  108.   (lambda (e)
  109.     '(vector-length (tutorial-frame-list *tutorial*))))
  110.  
  111. ;; form: (frame-list)
  112. ;; returns the tutorial's frame-list
  113. (macro frame-list
  114.   (lambda (e)
  115.     '(tutorial-frame-list *tutorial*)))
  116.  
  117. ;; form: (frame-number)
  118. ;; returns the frame-number of the current frame
  119. (macro frame-number
  120.   (lambda (e)
  121.     '(tutorial-frame-number *tutorial*)))
  122.  
  123. ;; form: (current-frame)
  124. ;; returns the current frame
  125. (macro current-frame
  126.   (lambda (e)
  127.     '(vector-ref (tutorial-frame-list *tutorial*)
  128.          (tutorial-frame-number *tutorial*))))
  129.  
  130. ;; form: (demo-writeln-extensions)
  131. ;; returns the function that handles text in a text zone
  132. (macro demo-writeln-extensions
  133.   (lambda (e)
  134.     `(tutorial-writeln-extensions *tutorial*)))
  135.  
  136. ;; this macro defines one "frame" -------------------------
  137.  
  138. (macro frame
  139.   (lambda (e)
  140.     `(push ',e (tutorial-frame-list *tutorial*))))
  141.  
  142. (macro frame-during-edit
  143.   (lambda (e)
  144.     `(set! *frame* ',e)))
  145.  
  146. ;; for popup windows (menus, help screens) -------------------------
  147.  
  148. ;; form: (with-popup-window dummy-window-var
  149. ;;        TITLE string
  150. ;;        TEXT-ATTRIBUTES attributes
  151. ;;        BORDER-ATTRIBUTES attributes
  152. ;;        POSITION (row . column)
  153. ;;        SIZE (rows . columns)
  154. ;;        &BODY &body)
  155. ;; The keywords aren't evaluated but the associated values are.
  156. (macro with-popup-window
  157.   (lambda (e)
  158.     (let ((w (cadr e))
  159.       (title (cadr (memq 'title e)))
  160.       (text-attributes (cadr (memq 'text-attributes e)))
  161.       (border-attributes (cadr (memq 'border-attributes e)))
  162.       (position (cadr (memq 'position e)))
  163.       (size (cadr (memq 'size e)))
  164.       (body (cdr (memq '&body e))))
  165.       `(let ((,w (make-window ,title #T)))
  166.      ,(when text-attributes
  167.         `(window-set-attribute! ,w 'text-attributes ,text-attributes))
  168.      ,(when border-attributes
  169.         `(window-set-attribute! ,w 'border-attributes ,border-attributes))
  170.      ,(when position
  171.         `(window-set-position! ,w (car ,position) (cdr ,position)))
  172.      ,(when size
  173.         `(window-set-size! ,w (car ,size) (cdr ,size)))
  174.      (window-popup ,w)
  175.      (begin0
  176.        (begin ,@body)
  177.        (window-popup-delete ,w))))))
  178.  
  179. ;; other -------------------------
  180.  
  181. ;; form: (center-at msg)
  182. ;; returns the column at which cursor must be positioned to
  183. ;; center msg on console window
  184. (macro center-at
  185.   (lambda (e)
  186.     (let ((msg (cadr e)))
  187.       `(- 40 (floor (/ (string-length ,msg) 2))))))
  188.  
  189. ;;; Auxiliary functions =========================
  190.  
  191. (define ATTR
  192.   (let ((attrs-ibm '((blink . 128) (bkg-white . 112)
  193.              (bkg-brown . 96) (bkg-magenta . 80) (bkg-cyan . 48)
  194.              (bkg-red . 64) (bkg-green . 32) (bkg-blue . 16)
  195.              (light-white . 15)
  196.              (yellow . 14) (light-magenta . 13) (light-red . 12)
  197.              (light-cyan . 11) (light-green . 10) (light-blue . 9)
  198.              (gray . 8) (white . 7) (brown . 6) (magenta . 5)
  199.              (red . 4) (cyan . 3) (green . 2) (blue . 1) (BLACK . 0)))
  200.     (attrs-ti  '((ALTCHAR . 128) (BLINK . 64)
  201.              (UNDERLINE . 32) (REVERSE . 16) (NODSP . -8)
  202.              (WHITE . 7) (YELLOW . 6) (cyan . 5) (GREEN . 4)
  203.              (PURPLE . 3) (RED . 2) (blue . 1) (BLACK . 0)))
  204.     (default-attrs-ibm 15)
  205.     (default-attrs-ti 15)
  206.     (prime-ibm 0)
  207.     (prime-ti 8))
  208.     (lambda x
  209.       (let ((work-fn
  210.           (LAMBDA (attrs default acc)
  211.         (COND
  212.           ((NULL? X)
  213.            (SET! ACC default))
  214.           ((NUMBER? (CAR X))
  215.            (SET! ACC (CAR X)))
  216.           (else
  217.             (MAPC
  218.               (LAMBDA (X)
  219.             (AND (ASSOC X ATTRS)
  220.                  (SET! ACC (+ ACC (CDR (ASSOC X ATTRS)))))) X)))
  221.         acc)))
  222.     (work-fn attrs-ibm default-attrs-ibm prime-ibm)))))
  223.  
  224. (define demo-writeln
  225.   (lambda (x w)          ;x=string of >=1 words, w=window
  226.     (mapc (lambda (word)
  227.         (cond (((demo-writeln-extensions) word w))
  228.           (else (display word w))))
  229.       (let loop ((word-list '()) (s x))
  230.         (let ((n (substring-find-next-char-in-set s 0 (string-length s) " ")))
  231.           (cond (n (loop (cons (substring s 0 (1+ n)) word-list)
  232.                  (substring s (1+ n) (string-length s))))
  233.             (else (reverse (cons (string-append s " ") word-list)))))))))
  234.  
  235. ;; a "filler" function
  236. (define (do-nothing . x) '())
  237.  
  238. ;(define visited
  239. ;  (lambda ()
  240. ;    (vector->list (tutorial-visited-list *tutorial*))))
  241.  
  242. ;;; Advertised public interface =========================
  243.  
  244. ;; Global variables -------------------------
  245.  
  246. (define *data-item*)
  247. (define *evaled-data-item*)
  248. (define *tutorial*)
  249. (define *auto-tutorial?* #F)
  250. (define *debug-tutorial* #F)         ;not advertised
  251. (define *frame* #F)             ;     "
  252.  
  253. ;; Exported functions -------------------------
  254.  
  255. (define start-tutorial)
  256. (define resume-tutorial)
  257.  
  258. ;;; the tutorial "engine" =========================
  259.  
  260. (letrec
  261.   ((alert
  262.      (lambda (msg)
  263.        (with-popup-window w
  264.      title ""
  265.      size `(1 . ,(string-length msg))
  266.      position `(5 . ,(center-at msg))
  267.      border-attributes (attr 'red)
  268.      text-attributes (attr 'black 'bkg-red)
  269.      &body
  270.      (beep)
  271.      (display msg w)
  272.      (read-char))))
  273.    (banner
  274.      (lambda ()
  275.        (window-clear 'console)
  276.        (with-popup-window w
  277.      title ""
  278.      size '(22 . 78)
  279.      position '(1 . 1)
  280.      &body
  281.      (let ((clear-msg "Press any key to continue.")
  282.            (banner
  283.          `("Texas Instruments"
  284.               "proudly presents:"
  285.               ""
  286.               "A PC Scheme Tutorial"
  287.               "on"
  288.               ,@(cond ((string? (tutorial-name *tutorial*))
  289.                    (list (tutorial-name *tutorial*)))
  290.                   ((pair?   (tutorial-name *tutorial*))
  291.                    (tutorial-name *tutorial*))
  292.                   (else
  293.                     (list "The Reliance of Programming on Thaumaturgy"))))))
  294.        (window-set-cursor! w 3 1)
  295.        (for-each (lambda (s)
  296.                (window-set-cursor!
  297.              w
  298.              (car (window-get-cursor w))
  299.              (center-at s))
  300.                (print s w)
  301.                (newline w))
  302.              banner)
  303.        (window-set-cursor!
  304.          w
  305.          21
  306.          (center-at clear-msg))
  307.        (display clear-msg w)
  308.        (tutorial-read-char)))))
  309.    (beep
  310.      (lambda ()
  311.        (display (integer->char 7))))
  312.    (busy-window
  313.      (let ((w (make-window #F #F)))
  314.        (window-set-size! w 1 20)
  315.        (window-set-attribute! w 'text-attributes (attr 'green 'blink))
  316.        w))
  317.    (calc-zone
  318.      (lambda (e)
  319.        (window-set-attribute! 'console 'text-attributes (attr 'green))
  320.        (clear-rest-of-visited-list (frame->number e))  ;force reanalysis of environment
  321.        (execute-frame-item e #T eval?)
  322.        (fresh-line)
  323.        (newline)))
  324.    (clear-rest-of-visited-list
  325.      (lambda (n)
  326.        (cond ((>= n (tutorial-length)))
  327.           (else
  328.            (vector-set! (tutorial-visited-list *tutorial*) n #F)
  329.            (clear-rest-of-visited-list (1+ n))))))
  330.    (clear-visited-list
  331.      (lambda ()
  332.        (vector-fill! (tutorial-visited-list *tutorial*) '())))
  333.    (collect-index
  334.      (lambda ()
  335.        (set! (tutorial-index *tutorial*)
  336.          (sort!
  337.            (let loop ((n 0) (acc '()))
  338.          (cond ((>= n (tutorial-length)) acc)
  339.                (else
  340.              (for-each (lambda (string)
  341.                      (let ((index-item (assoc string acc)))
  342.                        (cond (index-item
  343.                           (append! index-item (list n)))
  344.                          (else
  345.                           (push (list string n) acc)))))
  346.                    (frame-index-entry (nth-frame n)))
  347.              (loop (1+ n) acc))))
  348.            (lambda (x y)
  349.          (string-ci<? (car x) (car y)))))))
  350.    (collect-names
  351.      (lambda ()
  352.        (let loop ((n 0) (acc '()))
  353.      (cond ((>= n (tutorial-length))
  354.         (set! (tutorial-name-list *tutorial*) acc))
  355.            ((frame-name (nth-frame n))
  356.         (loop (1+ n) (cons (cons (frame-name (nth-frame n))
  357.                      n)
  358.                    acc)))
  359.            (else   ;give it a name and try again
  360.         (set-frame-name! (nth-frame n) (gensym))
  361.         (loop n acc))))))
  362.    (collect-tc
  363.      (lambda ()
  364.        (set! (tutorial-tc *tutorial*)
  365.          (sort!
  366.            (let loop ((n 0) (acc '()))
  367.          (cond ((>= n (tutorial-length))
  368.             acc)
  369.                ((frame-tc-entry (nth-frame n))
  370.             (loop (1+ n)
  371.                   (cons (list n (frame-tc-entry (nth-frame n))) acc)))
  372.                (else
  373.              (loop (1+ n) acc))))))
  374.        (when (>= (length (tutorial-tc *tutorial*)) 21)
  375.          (error "Only 20 entries are allowed in the tutorial table of contents."))))
  376.    (continue
  377.      (lambda ()
  378.        (let ((bad-key-msg "Invalid key pressed. \"?\" provides help."))
  379.      (fresh-line)
  380.      (display (integer->char 2))
  381.      (let again ((ch (tutorial-read-char)))
  382.        (case ch
  383.          (#\? (again (help)))
  384.          (#\backspace '())
  385.          ((#\e #\E) (again (if *debug-tutorial*
  386.                    (edit)
  387.                    (alert bad-key-msg))))
  388.          ((#\i #\I) (index))
  389.          ((#\p #\P) (again (previous-frame)))
  390.          ((#\q #\Q) (quit))
  391.          ((#\return #\space #\n #\N) (again (next-frame)))
  392.          ((#\t #\T) (table-of-contents))
  393.          (#T '())
  394.          (else (again (alert bad-key-msg))))))))
  395.    (display-title-window
  396.      (let ((blanks (make-string 15 #\space)))
  397.        (lambda ()
  398.      (window-clear title-window)
  399.      (display blanks title-window)
  400.      (print (frame-number) title-window)
  401.      (print blanks title-window)
  402.      (when (frame-tc-entry (current-frame))
  403.            (demo-writeln (frame-tc-entry (current-frame)) title-window)
  404.            (fresh-line title-window)
  405.            (newline title-window)))))
  406.    (do-tutorial
  407.      (named-lambda (loop)
  408.        (frame-1 (current-frame))
  409.        (loop)))
  410.    (edit
  411.      (lambda ()
  412.        (let ((prev-defn (getprop 'frame 'pcs*macro)))
  413.      (putprop 'frame (getprop 'frame-during-edit 'pcs*macro) 'pcs*macro)
  414.      (begin0
  415.        (with-popup-window
  416.          w
  417.          title "Edit menu"
  418.          size '(12 . 34)
  419.          position '(3 . 45)
  420.          &body
  421.          (print (assq (frame-name (current-frame)) (tutorial-name-list *tutorial*)) w)
  422.          (print (string-append "Frame evaluation is: " (if eval? "ON" "OFF")) w)
  423.          (print "" w)
  424.          (print "E - call Edwin" w)
  425.          (print "R - replace" w)
  426.          (print "T - new toplevel" w)
  427.          (print "V - toggle frame evaluation" w)
  428.          (print "and all standard keys" w)
  429.          (print "" w)
  430.          (let again ((ch (read-char)))
  431.            (case ch
  432.          ((#\e #\E)
  433.           (edwin)
  434.           (again (read-char)))
  435.          ((#\r #\R)
  436.           (cond ((frame? *frame*)
  437.              (set-frame-name! *frame* (frame-name (current-frame)))
  438.              (set! (current-frame) *frame*)
  439.              #T)
  440.             (else
  441.              (alert "Frame has bad format. Replace not done."))))
  442.          ((#\t #\T)  ;will this work?  YES!!
  443.           (beep)
  444.           (print "((fluid q)) quits new toplevel" w)
  445.           (let ((prev-history (getprop '%pcs-stl-history %pcs-stl-history)))
  446.             (call/cc
  447.               (lambda (k)
  448.             (fluid-let ((scheme-top-level '())
  449.                     (q (lambda () (k 'end-top-level))))
  450. ;               (set! pcs-gc-reset "((fluid q)) quits new toplevel")
  451.               (reset-scheme-top-level)
  452.               (reset))))
  453.             (set! pcs-gc-reset #F)
  454.             (putprop '%pcs-stl-history prev-history %pcs-stl-history)
  455.             #T))
  456.          ((#\v #\V)
  457.           (set! eval? (not eval?))
  458.           #\E)    ;force redisplay of edit menu
  459.          (else ch))))
  460.      (putprop 'frame prev-defn 'pcs*macro)))))
  461.    (end-frame
  462.      '(frame
  463.     ()
  464.     ("You have reached the end of the tutorial."
  465.      "Please press \"Q\" to exit.")))
  466.    (eval? #T)   ;var used in edit mode
  467.    (execute-frame-item
  468.      (lambda (e print? eval?)
  469.        (cond ((eq? (frame-visited? e) #T))
  470.          ((null? (frame-dependencies e))
  471.           (frame-item-parser (frame-item e) print? eval?)
  472.           (set-frame-visited! e #T))
  473.          (else
  474.           (when print?
  475.             (window-set-position! busy-window
  476.                       (car (window-get-cursor 'console))
  477.                       0)
  478.             (window-popup busy-window)    ;popdown when output occurs
  479.             (display "Evaluating..." busy-window))
  480.           (for-each (lambda (e)
  481.               (set! e (name->frame e))
  482.               (execute-frame-item e #F eval?))
  483.             (frame-dependencies e))
  484. ;           (when print?
  485. ;             (window-popup-delete busy-window))
  486.           (frame-item-parser (frame-item e) print? eval?)
  487.           (set-frame-visited! e #T)))))
  488.    (frame-1
  489.      (lambda (e)
  490.        (window-clear 'console)
  491.        (display-title-window)
  492.        (when (frame-lines-before e) (text-zone (frame-lines-before e)))
  493.        (when (frame-item e)        (calc-zone e))
  494.        (when (frame-lines-after e)  (text-zone (frame-lines-after e)))
  495.        (continue)))
  496.    (frame-item-parser
  497.      (lambda (cmds print? eval?)
  498.        (let loop ((cmds cmds))
  499.      (cond ((null? cmds))
  500.            (else
  501.          (case (car cmds)
  502.            (:data (set! *data-item* (cadr cmds))
  503.               (set! cmds (cdr cmds)))
  504. ;            (:read (set! *data-item* (read data-port)))
  505.            (:data-eval
  506.             (when eval? (set! *evaled-data-item* (eval *data-item*))))
  507.            (:eval
  508.             (when eval? (eval (cadr cmds)))
  509.             (set! cmds (cdr cmds)))
  510. ;            (:skip (read data-port))
  511.            ((:pp-data :pp-evaled-data :yields :fresh-line :output)
  512.             (when print?
  513.               (window-popup-delete busy-window)  ;popdown busy msg
  514.               (case (car cmds)
  515.                 (:output (when eval? (eval (cadr cmds)))
  516.                      (set! cmds (cdr cmds)))
  517.                 (:pp-data (pp *data-item*))
  518.                 (:pp-evaled-data (pp *evaled-data-item*))
  519.                 (:yields (display "  --->  "))
  520.                 (:fresh-line (fresh-line)))))
  521.            (else '()))
  522.          (loop (cdr cmds)))))))
  523.    (help
  524.      (lambda ()
  525.        (with-popup-window w
  526.      title "Help menu"
  527.      size '(12 . 34)
  528.      position '(3 . 45)
  529.      &body
  530.      (print "? - This menu" w)
  531.      (print "BACKSPACE - refresh screen" w)
  532.      (when *debug-tutorial*
  533.            (print "E - edit tutorial" w))
  534.      (print "I - index" w)
  535.      (print "N, RETURN, SPACE - next frame" w)
  536.      (print "P - previous frame" w)
  537.      (print "T - table of contents" w)
  538.      (print "Q - quit tutorial" w)
  539.      (read-char))))
  540.    (index
  541.      (lambda ()
  542.        (let ((prompt-msg "Please type a frame number, nil, U, or D, then RETURN: "))
  543.      (with-popup-window
  544.        w
  545.        title "Index"
  546.        size '(22 . 78)
  547.        position '(1 . 1)
  548.        &body
  549.        (let show-one-page ((n 0))
  550.          (window-clear w)
  551.          (let vloop ((start (list-tail (tutorial-index *tutorial*) n))
  552.              (end (list-tail (tutorial-index *tutorial*) (+ n 20))))
  553.            (cond ((eq? start end))
  554.              (else
  555.               (display "     " w)
  556.               (display (caar start) w)
  557.               (let hloop ((tab-to 27)
  558.                   (frame-no-list (cdar start)))
  559.             (cond ((null? frame-no-list))
  560.                   (else
  561.                    (tab (current-column w) tab-to 4 w)
  562.                    (display (car frame-no-list) w)
  563.                    (display " " w)
  564.                    (hloop (+ tab-to 4) (cdr frame-no-list)))))
  565.               (newline w)
  566.               (vloop (cdr start) end))))
  567.          (window-set-cursor! 'console 22 (center-at prompt-msg))
  568.          (display prompt-msg)
  569.          (let ((frame-no (read)))
  570.            (flush-input)
  571.            (cond ((and (number? frame-no)
  572.                (in-bounds? 0 frame-no (tutorial-length)))
  573.               (clear-visited-list)
  574.               (set! (frame-number) frame-no))
  575.              ((eq? frame-no 'U)
  576.               (show-one-page (if (< (- n 20) 0) 0 (- n 20))))
  577.              ((eq? frame-no 'D)
  578.               (show-one-page (if (>= (+ n 20) (length (tutorial-index *tutorial*)))
  579.                      n
  580.                      (+ n 20))))
  581.              ((and *debug-tutorial*
  582.                (assq frame-no (tutorial-name-list *tutorial*)))
  583.               (clear-visited-list)
  584.               (set! (frame-number) (cdr (assq frame-no (tutorial-name-list *tutorial*))))))
  585.            #T))))))
  586.    (init-tutorial
  587.      (lambda (tutorial resume)
  588.        (when (not (equal? *debug-tutorial* '(#\?)))  ;make it harder to enter debug mode
  589.          (set! *debug-tutorial* #F))
  590.        (when tutorial
  591.          (set! *tutorial* tutorial))
  592.        (when (not (tutorial? *tutorial*))
  593.          (alert "There is no tutorial available.")
  594.          (quit))
  595.        (when (and (unstarted-tutorial?)
  596.           resume)
  597.          (alert "You cannot resume an unstarted tutorial. Use (START-TUTORIAL).")
  598.          (quit))
  599.        (when (unstarted-tutorial?)
  600.          (set! (frame-list)
  601.            (list->vector (cons start-frame
  602.                        (reverse! (cons end-frame
  603.                                (frame-list))))))
  604.          (set! (tutorial-visited-list *tutorial*)
  605.            (make-vector (vector-length (frame-list))))
  606.          (set! (frame-number) 0)
  607.          (set! eval? #T)
  608.          (collect-names)
  609.          (collect-tc)
  610.          (collect-index))
  611.        (begin               ;make sure entire screen gets erased
  612.      (window-set-position! 'console 0 0)
  613.      (window-set-size! 'console 24 80)  ;leave status line
  614.      (window-set-attribute! 'console 'text-attributes (attr))
  615.      (window-clear 'console))
  616.        (when (not resume)
  617.          (banner)
  618.          (set! (frame-number) 0)
  619.          (clear-visited-list))
  620.        (call/cc
  621.      (lambda (k)
  622.        (set! quit-k (lambda ()
  623.               (k '())))
  624.        (call/cc (lambda (k)
  625.               (set! *user-error-handler*
  626.                 (lambda x (user-error-handler k)))))
  627.        (do-tutorial)))))
  628.    (next-frame
  629.      (lambda ()
  630.        (if (= (frame-number)
  631.            (-1+ (tutorial-length)))
  632.        (if *auto-tutorial?*
  633.            #\q
  634.            (alert "You are on the last frame of the tutorial."))
  635.        (begin (set! (frame-number) (1+ (frame-number)))
  636.           #T))))
  637.    (previous-frame
  638.      (lambda ()
  639.        (if (zero? (frame-number))
  640.        (alert "You are on the first frame of the tutorial.")
  641.        (begin (set! (frame-number) (-1+ (frame-number)))
  642.           #T))))
  643.    (print
  644.      (lambda (x w)
  645.        (display x w)
  646.        (newline w)))
  647.    (quit
  648.      (lambda ()
  649.        (window-clear 'console)
  650.        (set! *user-error-handler* #F)
  651.        (quit-k)))
  652.    (quit-k reset)         ;the quit continuation
  653.                  ;reassigned by init-tutorial
  654.    (start-frame
  655.      '(frame
  656.     ()
  657.     ()
  658.     (:data "A PC Scheme Tutorial" :pp-data)
  659.     ("The \"?\" is the help key."
  660.           "It displays a menu which tells you"
  661.           "about other important keys which enable you"
  662.           "to move around in the tutorial or to leave it."
  663.           "\"?\" or other single-keystroke keys are available"
  664.           "anytime you see the \"happy-face\" character towards"
  665.           "the bottom of the screen."
  666.           "Occasionally, typed input is requested."
  667.           "Typed input is"
  668.           "usually a number, or the atom NIL, followed by"
  669.           "the RETURN key."
  670.           "If you exit the tutorial in the middle, you can"
  671.           "continue from where you left off"
  672.           "(in the same session)"
  673.           "by typing (RESUME-TUTORIAL)."
  674.           "An \"Evaluating...\" message may appear while the"
  675.           "tutorial establishes"
  676.           "the proper execution environment for the examples in that"
  677.           "frame.")
  678.     ()
  679.     "Directions for running the tutorial"
  680.     ("directions for running tutorial")))
  681.    (tab
  682.      (lambda (cur goal multiple w)
  683.        (cond ((< cur goal)
  684.           (display " " w)
  685.           (tab (+ cur 1) goal multiple w))
  686.          ((= cur goal)
  687.           cur)
  688.          (else
  689.           (tab cur (+ goal multiple) multiple w)))))
  690.    (table-of-contents
  691.      (lambda ()
  692.        (let ((prompt-msg "Please type a frame number or nil then RETURN: "))
  693.      (with-popup-window
  694.        w
  695.        title "Table of Contents"
  696.        size '(22 . 78)
  697.        position '(1 . 1)
  698.        &body
  699.        (print "     Frame#          Subject" w)
  700.        (for-each (lambda (chapter-title)
  701.                (let ((n (car chapter-title))
  702.                  (title (cadr chapter-title)))
  703.              (display "        " w)
  704.              (display n w)
  705.              (display "        " w)
  706.              (display title w)
  707.              (newline w)))
  708.              (tutorial-tc *tutorial*))
  709.        (window-set-cursor! 'console 22 (center-at prompt-msg))
  710.        (display prompt-msg)
  711.        (let ((frame-no (read)))
  712.          (flush-input)
  713.          (cond ((and (number? frame-no)
  714.              (in-bounds? 0 frame-no (tutorial-length)))
  715.             (clear-visited-list)
  716.             (set! (frame-number) frame-no))
  717.            ((and *debug-tutorial*
  718.              (assq frame-no (tutorial-name-list *tutorial*)))
  719.             (clear-visited-list)
  720.             (set! (frame-number) (cdr (assq frame-no (tutorial-name-list *tutorial*))))))
  721.          #\backspace)))))
  722.    (text-zone
  723.      (lambda (lines)
  724.        (window-set-attribute! 'console 'text-attributes (attr))
  725.        (set-line-length! 55 'console)
  726.        (for-each (lambda (line) (demo-writeln line 'console)) lines)
  727.        (set-line-length! 80 'console)
  728.        (fresh-line)
  729.        (newline)))
  730.    (title-window
  731.      (let ((w (make-window #F #F)))
  732.        (window-set-position! w 0 60)
  733.        (window-set-size! w 10 20)
  734.        (window-set-attribute! w 'text-attributes (attr 'cyan))
  735.        w))
  736.    (tutorial-read-char
  737.      (lambda ()
  738.        (if *auto-tutorial?* #\space (read-char))))
  739.    (user-error-handler
  740.      (lambda (k)
  741.        (alert "System error in this frame.")
  742.        (if *debug-tutorial*
  743.        (set! eval? #F)      ;debugging, stay on current frame
  744.        (next-frame))         ;else go on to next frame
  745.        (k '())))
  746.    )
  747.   (set! (access frame-1 user-initial-environment) frame-1)
  748.   (set! start-tutorial
  749.     (lambda which
  750.       (init-tutorial (car which) #F)))
  751.   (set! resume-tutorial
  752.     (lambda which
  753.       (init-tutorial (car which) 'resume))))
  754.  
  755.